home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / Code Helpe270499272001.psc / Code Helper 2001 / Module1.bas < prev    next >
Encoding:
BASIC Source File  |  2001-09-19  |  7.2 KB  |  214 lines
  1. Attribute VB_Name = "ModFile"
  2. Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
  3. Declare Function SetActiveWindow Lib "user32" (ByVal hwnd As Long) As Long
  4. Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
  5.  
  6. Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
  7. Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
  8. Declare Function GetActiveWindow Lib "user32" () As Long
  9.  
  10. 'GetSystemFolders
  11. Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
  12. Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nSize As Long, ByVal lpBuffer As String) As Long
  13. Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
  14.  
  15. Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
  16.  
  17. Public DataFile As String
  18. Public Apath As String
  19. Public MyCode() As MCD
  20.  
  21. Public OldSearches As New Collection
  22.  
  23. Public Type MCD
  24.     EntryName As String
  25.     EntryValue As String ' This is the text
  26.     SearchTags() As String
  27.     EntryInfo As String
  28.     EntryPicName As String
  29. End Type
  30.  
  31. Public Enum SystemDirs
  32.     dirWindows = 0
  33.     dirSystem = 1
  34.     dirTemp = 2
  35. End Enum
  36.  
  37. Public Sub SetInfo()
  38. DataFile = "Win32Code2001.CDE"
  39. Apath = App.Path
  40. If Right(Apath, 1) <> "\" Then Apath = Apath & "\"
  41. End Sub
  42.  
  43. Function FileExist(File As String) As Boolean
  44. If Dir(File) <> "" Then
  45.     FileExist = True
  46. Else
  47.     FileExist = False
  48. End If
  49. End Function
  50.  
  51. 'Public Function SaveFile() As Boolean
  52.  
  53. 'End Function
  54.  
  55. Public Function OpenFile() As Boolean
  56.  
  57. On Local Error GoTo XF
  58.  
  59. Dim CurLine As String, i As Integer, j As Integer
  60. Dim TempVal As Integer, tmpArray() As String, TmpStg As String
  61.  
  62. If FileExist(Apath & DataFile) = True Then
  63.     If GetAttr(Apath & DataFile) = vbReadOnly Then
  64.         SetAttr Apath & DataFile, vbNormal
  65.     End If
  66.     
  67.     'ReDim MyCode(0)
  68.     
  69.     Close #1
  70.     Open Apath & DataFile For Input As #1
  71.         Do Until EOF(1)
  72.             Line Input #1, CurLine
  73.             If Trim(CurLine) <> "" And Left(CurLine, 2) <> "//" Then
  74.                 If Left(MyTrim(CurLine), 15) = "<entry number>=" Then
  75.                     ReDim Preserve MyCode(i)
  76.                     MyCode(i).EntryName = ""
  77.                     MyCode(i).EntryValue = ""
  78.                     i = i + 1
  79.                 ElseIf Left(MyTrim(CurLine), 13) = "<entry name>=" Then
  80.                     MyCode(i - 1).EntryName = Mid(MyTrim(CurLine, False), 14)
  81.                 ElseIf Left(MyTrim(CurLine), 6) = "<txt>=" Then
  82.                     MyCode(i - 1).EntryValue = MyCode(i - 1).EntryValue & Mid(MyTrim(CurLine, False), 7)
  83.                 ElseIf Left(MyTrim(CurLine), 6) = "<ret>=" Then
  84.                     TempVal = CInt(Mid(MyTrim(CurLine), 7))
  85.                     If TempVal <> 0 Then
  86.                         For j = 1 To TempVal
  87.                             MyCode(i - 1).EntryValue = MyCode(i - 1).EntryValue & vbCrLf
  88.                         Next j
  89.                     End If
  90.                 ElseIf Left(MyTrim(CurLine), 14) = "<search tags>=" Then
  91.                     If Len(MyTrim(CurLine)) > 15 Then
  92.                         Call Split(Mid(MyTrim(CurLine, False), 15), " ", MyCode(i - 1).SearchTags(), 0)
  93.                     End If
  94.                 ElseIf Left(MyTrim(CurLine), 7) = "<info>=" Then
  95.                     MyCode(i - 1).EntryInfo = MyCode(i - 1).EntryInfo & Mid(CurLine, 8)
  96.                 ElseIf Left(MyTrim(CurLine), 7) = "<reti>=" Then
  97.                     TempVal = CInt(Mid(MyTrim(CurLine), 8))
  98.                     If TempVal <> 0 Then
  99.                         For j = 1 To TempVal
  100.                             MyCode(i - 1).EntryInfo = MyCode(i - 1).EntryInfo & vbCrLf
  101.                         Next j
  102.                     End If
  103.                 ElseIf Left(MyTrim(CurLine), 11) = "<pic name>=" Then
  104.                     If Len(CurLine) > 11 Then
  105.                         MyCode(i - 1).EntryPicName = MyTrim(Mid(CurLine, 12), False)
  106.                     End If
  107.                 End If
  108.             End If
  109.             On Local Error Resume Next
  110.             If i <> 0 Then
  111.                 TmpStg = MyCode(i - 1).SearchTags(0)
  112.                 If Err.Number = 9 Then
  113.                     ReDim Preserve MyCode(i - 1).SearchTags(0)
  114.                     Err.Clear
  115.                 End If
  116.                 TmpStg = ""
  117.                 On Local Error GoTo XF
  118.             End If
  119.             DoEvents
  120.         Loop
  121.     Close #1
  122.     
  123. End If
  124. Exit Function
  125. XF:
  126. MsgBox Err.Number & vbTab & Err.Description, vbCritical, "Error"
  127. End Function
  128.  
  129.  
  130.  
  131. Function MyTrim(Stg As String, Optional mkLowerCase As Boolean = True) As String
  132. Dim Strga As String
  133. Strga = Trim(Stg)
  134. If mkLowerCase = True Then Strga = LCase(Strga)
  135. Do Until Left(Strga, 1) <> vbTab
  136.     'If Left(Strga, 1) = vbTab Then
  137.         Strga = Mid(Strga, 2)
  138.     'End If
  139. Loop
  140. MyTrim = Strga
  141. End Function
  142.  
  143.  
  144.  
  145. Public Function Split(chaine As String, Separator As String, destArray() As String, ArrayStartNum As Integer) As Integer
  146.     On Error GoTo erreur
  147.     Dim pos_act As Integer, pos_occur As Integer
  148.     If Right(chaine, 1) <> Separator Then chaine = chaine & Separator
  149.     Do
  150.         pos_act = pos_occur + Len(Separator)
  151.         pos_occur = InStr(pos_act, chaine, Separator)
  152.         If pos_occur <> 0 Then
  153.             ReDim Preserve destArray(ArrayStartNum)
  154.             destArray(ArrayStartNum) = Mid(chaine, pos_act, pos_occur - pos_act)
  155.             ArrayStartNum = ArrayStartNum + 1
  156.         End If
  157.     Loop Until pos_occur = 0
  158.     Split = 0
  159. Exit Function
  160.  
  161. erreur:
  162.     Split = Err.Number
  163. End Function
  164.  
  165. Sub OpenNotePad()
  166. Dim TmpStg As String
  167.  
  168.     TmpStg = GetSystemFolders(dirWindows)
  169.     If Right(TmpStg, 1) <> "\" Then TmpStg = TmpStg & "\"
  170.     TmpStg = TmpStg & "Notepad.exe"
  171.     Call Shell(TmpStg, vbNormalFocus)
  172.  
  173. End Sub
  174.  
  175. Public Sub SendText(WindowHandle As Long, Text As String)
  176.     ' Sends the Text to the given window han
  177.     '     dle
  178.     Dim ReturnValue As Long
  179.     ReturnValue = SendMessageByString(WindowHandle, WM_SETTEXT, 0&, Text)
  180. End Sub
  181.  
  182. Public Function GetSystemFolders(func As SystemDirs)
  183. Dim r, nSize As Long, tmp As String
  184.  tmp = Space$(256):    nSize = Len(tmp)
  185. Select Case func
  186.    Case 0
  187.       r = GetWindowsDirectory(tmp, nSize):     GetSystemFolders = TrimNull(tmp)
  188.     Case 1
  189.       r = GetSystemDirectory(tmp, nSize):      GetSystemFolders = TrimNull(tmp)
  190.     Case 2
  191.        r = GetTempPath(nSize, tmp):       GetSystemFolders = TrimNull(tmp)
  192.     End Select
  193. End Function
  194.  
  195. Private Function TrimNull(Item As String)
  196.     Dim pos As Integer:    pos = InStr(Item, Chr$(0))
  197.     If pos Then
  198.           TrimNull = Left$(Item, pos - 1)
  199.     Else: TrimNull = Item
  200.     End If
  201. End Function
  202.  
  203. Function GetIndex(cName As String) As Integer
  204.     On Error GoTo XF
  205.     For i = 0 To UBound(MyCode)
  206.         If cName = MyCode(i).EntryName Then
  207.             GetIndex = i
  208.             Exit Function
  209.         End If
  210.     Next i
  211. XF:
  212. End Function
  213.  
  214.